home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / read.scm < prev    next >
Text File  |  1995-10-13  |  8KB  |  267 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; A little Scheme reader.
  6.  
  7. ; Nonstandard things used:
  8. ;  Ascii stuff: char->ascii, ascii->char, ascii-whitespaces, ascii-limit
  9. ;    (for dispatch table; portable definitions in alt/ascii.scm)
  10. ;  reverse-list->string  -- ok to define as follows:
  11. ;    (define (reverse-list->string l n)
  12. ;      (list->string (reverse l)))
  13. ;  make-immutable! -- ok to define as follows:
  14. ;    (define (make-immutable! x) x)
  15. ;  signal (only for use by reading-error; easily excised)
  16.  
  17.  
  18. (define (read . port-option)
  19.   (let ((port (input-port-option port-option)))
  20.     (let loop ()
  21.       (let ((form (sub-read port)))
  22.         (cond ((not (reader-token? form)) form)
  23.               ((eq? form close-paren)
  24.                ;; Too many right parens.
  25.            (warn "discarding extraneous right parenthesis")
  26.                (loop))
  27.           (else
  28.            (reading-error port (cdr form))))))))
  29.  
  30. (define (sub-read-carefully port)
  31.   (let ((form (sub-read port)))
  32.     (cond ((eof-object? form)
  33.            (reading-error port "unexpected end of file"))
  34.       ((reader-token? form) (reading-error port (cdr form)))
  35.       (else form))))
  36.  
  37. (define reader-token-marker (list 'reader-token))
  38. (define (make-reader-token message) (cons reader-token-marker message))
  39. (define (reader-token? form)
  40.   (and (pair? form) (eq? (car form) reader-token-marker)))
  41.  
  42. (define close-paren (make-reader-token "unexpected right parenthesis"))
  43. (define dot         (make-reader-token "unexpected \" . \""))
  44.  
  45.  
  46. ; Main dispatch
  47.  
  48. (define (sub-read port)
  49.   (let ((c (read-char port)))
  50.     (if (eof-object? c)
  51.         c
  52.         ((vector-ref read-dispatch-vector (char->ascii c))
  53.          c port))))
  54.  
  55. (define read-dispatch-vector
  56.   (make-vector ascii-limit
  57.                (lambda (c port)
  58.                  (reading-error port "illegal character read" c))))
  59.  
  60. (define read-terminating?-vector
  61.   (make-vector ascii-limit #t))
  62.  
  63. (define (set-standard-syntax! char terminating? reader)
  64.   (vector-set! read-dispatch-vector     (char->ascii char) reader)
  65.   (vector-set! read-terminating?-vector (char->ascii char) terminating?))
  66.  
  67. (let ((sub-read-whitespace
  68.        (lambda (c port)
  69.          c                              ;ignored
  70.          (sub-read port))))
  71.   (for-each (lambda (c)
  72.               (vector-set! read-dispatch-vector c sub-read-whitespace))
  73.             ascii-whitespaces))
  74.  
  75. (let ((sub-read-constituent
  76.        (lambda (c port)
  77.      (parse-token (sub-read-token c port) port))))
  78.   (for-each (lambda (c)
  79.               (set-standard-syntax! c #f sub-read-constituent))
  80.             (string->list
  81.              (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
  82.                             "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))
  83.  
  84. ; Usual read macros
  85.  
  86. (define (set-standard-read-macro! c terminating? proc)
  87.   (set-standard-syntax! c terminating? proc))
  88.  
  89. (define (sub-read-list c port)
  90.   (let ((form (sub-read port)))
  91.     (cond ((eof-object? form)
  92.            (reading-error port
  93.               "end of file inside list -- unbalanced parentheses"))
  94.           ((eq? form close-paren) '())
  95.           ((eq? form dot)
  96.            (let* ((last-form (sub-read-carefully port))
  97.                   (another-form (sub-read port)))
  98.              (cond ((eq? another-form close-paren) last-form)
  99.                    (else
  100.                     (reading-error port
  101.                    "randomness after form after dot"
  102.                    another-form)))))
  103.           (else (cons form (sub-read-list c port))))))
  104.  
  105. (set-standard-read-macro! #\( #t sub-read-list)
  106.  
  107. (set-standard-read-macro! #\) #t
  108.   (lambda (c port)
  109.     c port
  110.     close-paren))
  111.  
  112. (set-standard-read-macro! #\' #t
  113.   (lambda (c port)
  114.     c
  115.     (list 'quote (sub-read-carefully port))))
  116.  
  117. (set-standard-read-macro! #\` #t
  118.   (lambda (c port)
  119.     c
  120.     (list 'quasiquote (sub-read-carefully port))))
  121.  
  122. (set-standard-read-macro! #\, #t
  123.   (lambda (c port)
  124.     c
  125.     (let* ((next (peek-char port))
  126.        ;; DO NOT beta-reduce!
  127.        (keyword (cond ((eof-object? next)
  128.                (reading-error port "end of file after ,"))
  129.               ((char=? next #\@)
  130.                (read-char port)
  131.                'unquote-splicing)
  132.               (else 'unquote))))
  133.       (list keyword
  134.             (sub-read-carefully port)))))
  135.  
  136. (set-standard-read-macro! #\" #t
  137.   (lambda (c port)
  138.     c ;ignored
  139.     (let loop ((l '()) (i 0))
  140.       (let ((c (read-char port)))
  141.         (cond ((eof-object? c)
  142.                (reading-error port "end of file within a string"))
  143.               ((char=? c #\\)
  144.                (let ((c (read-char port)))
  145.          (cond ((eof-object? c)
  146.             (reading-error port "end of file within a string"))
  147.                ((or (char=? c #\\) (char=? c #\"))
  148.             (loop (cons c l) (+ i 1)))
  149.                (else
  150.             (reading-error port
  151.                        "invalid escaped character in string"
  152.                        c)))))
  153.               ((char=? c #\")
  154.            (reverse-list->string l i))
  155.               (else
  156.            (loop (cons c l) (+ i 1))))))))
  157.  
  158. (set-standard-read-macro! #\; #t
  159.   (lambda (c port)
  160.     c ;ignored
  161.     (gobble-line port)
  162.     (sub-read port)))
  163.  
  164. (define (gobble-line port)
  165.   (let loop ()
  166.     (let ((c (read-char port)))
  167.       (cond ((eof-object? c) c)
  168.         ((char=? c #\newline) #f)
  169.         (else (loop))))))
  170.  
  171. (define *sharp-macros* '())
  172.  
  173. (define (define-sharp-macro c proc)
  174.   (set! *sharp-macros* (cons (cons c proc) *sharp-macros*)))
  175.  
  176. (set-standard-read-macro! #\# #f
  177.   (lambda (c port)
  178.     c ;ignored
  179.     (let* ((c (peek-char port))
  180.        (c (if (eof-object? c)
  181.           (reading-error port "end of file after #")
  182.           (char-downcase c)))
  183.        (probe (assq c *sharp-macros*)))
  184.       (if probe
  185.       ((cdr probe) c port)
  186.       (reading-error port "unknown # syntax" c)))))
  187.  
  188. (define-sharp-macro #\f
  189.   (lambda (c port) (read-char port) #f))
  190.  
  191. (define-sharp-macro #\t
  192.   (lambda (c port) (read-char port) #t))
  193.  
  194. (define-sharp-macro #\\
  195.   (lambda (c port)
  196.     (read-char port)
  197.     (let ((c (peek-char port)))
  198.       (cond ((eof-object? c)
  199.          (reading-error port "end of file after #\\"))
  200.         ((char-alphabetic? c)
  201.          (let ((name (sub-read-carefully port)))
  202.            (cond ((= (string-length (symbol->string name)) 1)
  203.               c)
  204.              ((assq name '((space   #\space)
  205.                    (newline #\newline)))
  206.               => cadr)
  207.              (else
  208.               (reading-error port "unknown #\\ name" name)))))
  209.         (else
  210.          (read-char port))))))
  211.  
  212. (define-sharp-macro #\(
  213.   (lambda (c port)
  214.     (read-char port)
  215.     (list->vector (sub-read-list c port))))
  216.  
  217. (let ((number-sharp-macro
  218.        (lambda (c port)
  219.      (let ((string (sub-read-token #\# port)))
  220.        (or (string->number string)
  221.            (reading-error port "unsupported number syntax" string))))))
  222.   (for-each (lambda (c)
  223.           (define-sharp-macro c number-sharp-macro))
  224.         '(#\b #\o #\d #\x #\i #\e)))
  225.  
  226. ; Tokens
  227.  
  228. (define (sub-read-token c port)
  229.   (let loop ((l (list (preferred-case c))) (n 1))
  230.     (let ((c (peek-char port)))
  231.       (cond ((or (eof-object? c)
  232.                  (vector-ref read-terminating?-vector (char->ascii c)))
  233.              (reverse-list->string l n))
  234.             (else
  235.              (loop (cons (preferred-case (read-char port)) l)
  236.                    (+ n 1)))))))
  237.  
  238. (define (parse-token string port)
  239.   (if (let ((c (string-ref string 0)))
  240.     (or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
  241.       (cond ((string->number string))
  242.         ((member string strange-symbol-names)
  243.          (string->symbol (make-immutable! string)))
  244.         ((string=? string ".")
  245.          dot)
  246.         (else
  247.          (reading-error port "unsupported number syntax" string)))
  248.       (string->symbol (make-immutable! string))))
  249.  
  250. (define strange-symbol-names
  251.   '("+" "-" "..."
  252.     "1+" "-1+"  ;Only for S&ICP support
  253.     "->"        ;Only for JAR's thesis
  254.     ))
  255.  
  256. (define preferred-case
  257.   (if (char=? (string-ref (symbol->string 't) 0) #\T)
  258.       char-upcase
  259.       char-downcase))
  260.  
  261.  
  262. ; Reader errors
  263.  
  264. (define (reading-error port message . irritants)
  265.   (apply signal 'read-error message
  266.      (append irritants (list port))))
  267.